home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / mchoices.lisp < prev    next >
Encoding:
Text File  |  1990-07-19  |  8.8 KB  |  225 lines
  1. ;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (EXPORT '(
  24.       choice-default
  25.       choice-font
  26.       choice-selection
  27.       make-multiple-choices
  28.       multiple-choices
  29.       ))
  30.  
  31.  
  32. ;;;  ============================================================================
  33. ;;;         T h e   M U L T I P L E   -   C H O I C E S   C o n t a c t
  34. ;;;  ============================================================================
  35.  
  36. (DEFCONTACT multiple-choices (table)
  37.   
  38.   ((font     :type         fontable
  39.          :reader     choice-font
  40.         :initarg    :font
  41.          :initform     nil)
  42.     
  43.    (selection   :type           list
  44.                 :accessor       choice-selection
  45.                 :initform       nil)
  46.  
  47.    (default    :type        list
  48.                 :accessor       choice-default
  49.         :initarg    :default-selection
  50.         :initform    nil)
  51.    )
  52.   
  53.   (:resources
  54.     font default
  55.     (horizontal-space :initform 3)
  56.     (vertical-space :initform 3))
  57.  
  58.   (:documentation
  59.     "Provides a mechanism for displaying N choices to a user of which the user may select M,
  60. where N >= M >= 0."))
  61.  
  62.  
  63.  
  64. (DEFUN make-multiple-choices (&rest initargs &key &allow-other-keys)
  65.   (DECLARE (VALUES multiple-choices))
  66.   (APPLY #'make-contact 'multiple-choices initargs))
  67.  
  68.  
  69. (DEFMETHOD add-child :after ((choices multiple-choices) this-child &key)
  70.   (flet
  71.     (
  72.      ;;; ===============================================================================
  73.      ;;;
  74.      ;;;       Our :changing and :canceling-change callback functions...
  75.      ;;;
  76.      (choices-changing (to-selected-p choices self)
  77.        (DECLARE (IGNORE self))
  78.        (LET((selection (choice-selection choices))
  79.         (default (choice-default choices)))
  80.  
  81.      (WHEN default
  82.        ;; If there is a current choice default then we *may* have
  83.        ;; to temporarily inhibit display of the default ring.
  84.        (UNLESS (and selection to-selected-p)
  85.          ;; If there is a current selection already and we are
  86.          ;; transitioning *to* selected state then the default ring(s)
  87.          ;; are already inhibited.  Otherwise, there are two possibilites:
  88.          ;; (1) No selection, transitioning *to* selected.
  89.          ;;     We must inhibit ring display on all defaults.
  90.          ;; (2) Have selection, transitioning *from* selected.
  91.          ;;     If there is only one selection and it is transitioning to
  92.          ;;     unselected, then we must restore default ring(s) display.
  93.          (let
  94.            ((highlighted-p (not to-selected-p)))
  95.            (when (or to-selected-p (null (cdr selection)))
  96.          (DOLIST (item default)
  97.            (SETF (choice-item-highlight-default-p item) highlighted-p))))))))
  98.  
  99.      (choices-canceling-change (to-selected-p choices self)
  100.        (DECLARE (IGNORE self))
  101.        (LET((selection (choice-selection choices))
  102.         (default (choice-default choices)))
  103.  
  104.      (WHEN default
  105.        ;; If we are canceling a transition to "selected" then we
  106.        ;; must restore the inhibited default ring display.
  107.        ;; If, on the other hand, we are canceling a transition
  108.        ;; back to "unselected" then we must once again inhibit
  109.        ;; default ring display.
  110.        (UNLESS (and selection to-selected-p)
  111.          ;; As in choices-changing, if there is a current selection
  112.          ;; already inhibiting default ring display then we need not
  113.          ;; restore display here.
  114.          (when (or to-selected-p (null (cdr selection)))
  115.          (DOLIST (item default)
  116.            (SETF (choice-item-highlight-default-p item) to-selected-p)))))))
  117.  
  118.  
  119.      ;;; ================================================================================
  120.      ;;;    This :off callback (destructively) removes the item from the current
  121.      ;;;        selection set for this multiple-choices contact.
  122.      ;;;
  123.      (choices-off (choices self)
  124.        (WITH-SLOTS (selection) choices
  125.      (WHEN selection (SETF selection (DELETE self selection)))))
  126.  
  127.      ;;; ================================================================================
  128.      ;;;    This :on callback adds the item to the current selection set
  129.      ;;;        for this multiple-choices contact.
  130.      ;;;
  131.      (choices-on (choices self)
  132.        (WITH-SLOTS (selection) choices
  133.      ;; It is important to *not* use the SETF method here since doing so would
  134.      ;; potentially cause a loop. [SETF method invokes this callback!]
  135.      (SETF selection (cons self selection))))
  136.      )                        ; ... end of flet ...
  137.  
  138.     (let((font (choice-font choices)))
  139.       (WHEN font (SETF (choice-item-font this-child) font)))
  140.  
  141.     ;;  =====================================================================================
  142.     ;;  If this child's name is on the default-selection list, replace it with this child.
  143.     ;;
  144.     (with-slots (default) choices
  145.       (DO ((defaults default (REST defaults)))
  146.       ((NULL defaults))
  147.     (WHEN (EQ (FIRST defaults) (contact-name this-child))
  148.       (RPLACA defaults this-child)
  149.       (SETF (choice-item-highlight-default-p this-child) T)
  150.       (RETURN))))
  151.  
  152.     (add-callback this-child :changing #'choices-changing choices this-child)
  153.     (add-callback this-child :canceling-change #'choices-canceling-change choices this-child)
  154.     (add-callback this-child :on #'choices-on choices this-child)
  155.     (add-callback this-child :off #'choices-off choices this-child)))
  156.  
  157.  
  158. ;;; ===============================================================================
  159. ;;;
  160. ;;;              Method to set the default choice item set
  161. ;;;
  162.  
  163. (DEFMETHOD (SETF choice-default) (new-default-choice-items (choices multiple-choices))
  164.   (with-slots (default children) choices
  165.     (let
  166.       ((new-defaults (set-difference new-default-choice-items default))
  167.        (no-longer-defaults (set-difference default new-default-choice-items)))
  168.       (WHEN new-defaults
  169.     (ASSERT (subsetp new-defaults children)
  170.         NIL
  171.         "New default choice-items ~a are not children of ~a."
  172.         (set-difference new-defaults children) choices)
  173.     
  174.     (DOLIST (item new-defaults)
  175.       (SETF (choice-item-highlight-default-p item) T))
  176.     (DOLIST (item no-longer-defaults)
  177.       (SETF (choice-item-highlight-default-p item) NIL))
  178.     (SETF default new-default-choice-items))))
  179.   new-default-choice-items)
  180.  
  181.  
  182. ;;; ===============================================================================
  183. ;;;
  184. ;;;            Methods to set the selected choice-items set
  185. ;;;
  186. (DEFMETHOD (SETF choice-selection) (children-to-be-selected (choices multiple-choices))
  187.  
  188.   (DECLARE (TYPE list children-to-be-selected))
  189.   (DECLARE (VALUES children-to-be-selected))
  190.   
  191.   (with-slots (children selection) choices
  192.     (let
  193.       ((new-selections (set-difference children-to-be-selected selection))
  194.        (no-longer-selected (set-difference selection children-to-be-selected)))
  195.     
  196.     ;;  Make sure the caller's selection are indeed a children of ours...
  197.     (ASSERT (subsetp new-selections children)
  198.         NIL
  199.       "Selections ~a are not children of ~a." (set-difference new-selections selection) choices)
  200.  
  201.     ;; Clear selected status of items no longer selected
  202.     (DOLIST (item no-longer-selected)
  203.       (SETF (choice-item-selected-p item) NIL))
  204.     ;; Set selected status of items newly selected
  205.     (DOLIST (item new-selections)
  206.       (SETF (choice-item-selected-p item) T))))
  207.   children-to-be-selected)
  208.  
  209. ;;; ===============================================================================
  210. ;;;
  211. ;;;                   Method to force the font of all children...
  212. ;;;
  213.  
  214. (DEFMETHOD (SETF choice-font) (new-value (multiple-choices multiple-choices))
  215.   
  216.   (with-slots (children font) multiple-choices
  217.     (if new-value
  218.     (progn
  219.       (SETF font (find-font multiple-choices new-value))
  220.       (DOLIST (child children)
  221.         (SETF (choice-item-font child) new-value)))
  222.     (SETF font NIL))
  223.     new-value))
  224.  
  225.